home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TSPA3470 / TSUNTG.TST < prev    next >
Text File  |  1994-08-16  |  6KB  |  251 lines
  1. {$M 16384,0,655360}
  2.  
  3. (* This is a test program for the TSUNTG.TPU unit
  4.    Updated 26-Nov-89, 6-Dec-89, 14-Jun-90, 22-Jul-90, 1-Aug-90,
  5.            8-Aug-90, 27-Oct-91, 13-Jun-92, 19-Oct-92, 8-Nov-92,
  6.            26-Jul-93, 23-Jun-94 *)
  7.  
  8. uses Dos,
  9.      TSUNTB,  (* to have access to number base conversion *)
  10.      TSUNTG
  11.      {$IFDEF VER40}
  12.      ,TSUNT45
  13.      {$ENDIF}
  14.      ;
  15.  
  16. procedure LOGO;
  17. begin
  18.   writeln;
  19.   writeln ('TSUNTG unit test by Prof. Timo Salmi');
  20.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  21. {$IFDEF VER40}
  22.   writeln ('TP version 4.0');
  23. {$ENDIF}
  24. {$IFDEF VER50}
  25.   writeln ('TP version 5.0');
  26. {$ENDIF}
  27. {$IFDEF VER55}
  28.   writeln ('TP version 5.5');
  29. {$ENDIF}
  30. {$IFDEF VER60}
  31.   writeln ('TP version 6.0');
  32. {$ENDIF}
  33. {$IFDEF VER70}
  34.   writeln ('TP version 7.0');
  35. {$ENDIF}
  36.   writeln;
  37. end;
  38.  
  39. (* Number of diskette drives *)
  40. procedure TEST1;
  41. begin
  42.   writeln ('Number of diskette drives on this system is ', DRIVESFN);
  43. end; (* test1 *)
  44.  
  45. (* Number of disk devices *)
  46. procedure TEST2;
  47. begin
  48. {$IFDEF VER50}
  49.   if swap(DosVersion) < $0300 then
  50.     begin writeln ('Not MsDos 3.+'); exit; end;
  51. {$ENDIF}
  52.   writeln ('Number of disks on this system is ', DSKCNTFN);
  53. end;  (* test2 *)
  54.  
  55. (* Number of diskette drives *)
  56. procedure TEST3;
  57. begin
  58.   writeln ('The first diskette drive is ', FDRIVEFN);
  59. end; (* test3 *)
  60.  
  61. (* Is a media present in the drive *)
  62. procedure TEST4;
  63. const drive = 'B';
  64. begin
  65.   If INDRIVFN (drive) then
  66.     writeln ('Disk present in drive ', drive)
  67.   else
  68.     writeln ('Disk not present in drive ', drive);
  69. end;  (* test4 *)
  70.  
  71. (* Cursor location test *)
  72. procedure TEST5;
  73. var x , y : byte;
  74. begin
  75.   GOATXY (10, 20);
  76.   write ('▓The block is at 10,20 .');
  77.   x := WHEREXFN - 1; y := WHEREYFN;
  78.   write (' and the point at ', x:0, ',', y:0);
  79. end;  (* test5 *)
  80.  
  81. (* Reverse the colors of an area *)
  82. procedure TEST6;
  83. begin
  84.   REVAREA (2, 2, 79, 24);
  85.   GOATXY (1, 22);
  86. end;  (* test6 *)
  87.  
  88. (* Redirection of writes *)
  89. procedure TEST7;
  90. begin
  91.   writeln ('If you get runtime error 160, first test for printer readiness');
  92.   writeln ('TSUNTC has the relevant routines');
  93.   writeln;
  94.   USEPRN;
  95.   writeln ('This goes to the printer');
  96.   writeln ('As does this');
  97.   USECON;
  98.   write   ('This goes on the screen');
  99. end;  (* test7 *)
  100.  
  101. (* Test whether a media is a fixed disk *)
  102. procedure TEST8;
  103. var drive : string;
  104. begin
  105.   write ('Enter drive letter? '); readln (drive);
  106.   case Length (drive) of
  107.     0  : drive := '0';
  108.     else drive := UpCase(drive[1]);
  109.   end;
  110.   if FIXEDFN (drive[1]) then
  111.      writeln ('Media ', drive , ' is a fixed disk')
  112.    else
  113.      writeln ('Media ', drive , ' is not a fixed disk');
  114. end;  (* test8 *)
  115.  
  116. (* Test whether ANSI.SYS or a comparable driver has been loaded *)
  117. procedure TEST9;
  118. begin
  119.   if ISANSIFN then
  120.     writeln ('ANSI.SYS or a comparable screen driver has been installed')
  121.   else
  122.     begin
  123.       writeln;
  124.       writeln ('ANSI.SYS or a comparable screen driver has not been installed');
  125.     end;
  126. end;  (* test9 *)
  127.  
  128. (* Test the disk status *)
  129. procedure TEST10;
  130. const drive = 'A';
  131. var status : integer;
  132. begin
  133.   status := FLOPSTFN (drive);
  134.   if status = -1 then
  135.     begin
  136.       writeln ('Invalid drive, must be A or B');
  137.       exit;
  138.     end; {if}
  139.   writeln ('Disk status for ', drive, ': $', BHEXFN(status));
  140.   case status of
  141.     $00 : writeln ('Disk present');
  142.     $02 : writeln ('Address mark not found (Disk unformatted)');
  143.     $40 : writeln ('Seek failure (Disk not present?)');
  144.     $80 : writeln ('Disk timed out (Disk not present in drive)');
  145.   end;
  146. end;  (* test10 *)
  147.  
  148. (* Test whether a drive is a substituted drive *)
  149. procedure TEST11;
  150. const drive = 'R';
  151. var isubst : boolean;
  152. begin
  153.   if (100*Lo(DosVersion) + Hi(DosVersion)) < 310 then
  154.     begin
  155.       writeln ('The MsDos version must be at least 3.1');
  156.       exit;
  157.     end;
  158.   isubst := ISUBSTFN (drive);
  159.   writeln ('Drive ', drive, ' is a substituted drive is ', isubst);
  160. end;  (* test11 *)
  161.  
  162. (* What kind of a disk is in the drive *)
  163. procedure TEST12;
  164. const drive = 'B';
  165. var mediaID : byte;
  166. begin
  167.   mediaID := MEDIAFN (drive);
  168.   write ('Media currently in drive ', drive, ': is ');
  169.   case mediaID of
  170.     $00 : writeln ('Error');
  171.     $F0 : writeln ('Floppy of 1.44Mb');
  172.     $F8 : writeln ('Fixed disk');
  173.     $F9 : writeln ('Floppy of 1.2Mb');
  174.     $FA : writeln ('Floppy of 720Kb');
  175.     $FD : writeln ('Floppy of 360Kb');
  176.     $FF : writeln ('Floppy of 320Kb');
  177.     else  writeln ('something else');
  178.   end; {case}
  179. end;  (* test12 *)
  180.  
  181. (* Get the currently active floppy drive on one drive systems *)
  182. procedure TEST13;
  183. var active : char;
  184. begin
  185.   active := ACTDRVFN;
  186.   write ('The currently active floppy drive is ');
  187.   case active of
  188.     '0' : writeln ('Error ');
  189.     'A' : writeln ('A:');
  190.     'B' : writeln ('B:');
  191.     '2' : writeln ('not relevant (Two or more drives)');
  192.   end;
  193. end;  (* test13 *)
  194.  
  195. (* Test if a drive is a ram disk *)
  196. procedure TEST14;
  197. const drive = 'B';
  198. var status : boolean;
  199. begin
  200.   status := ISRAMFN (drive);
  201.   writeln ('Drive ', drive, ' is a ramdrive is ', status);
  202. end;  (* test14 *)
  203.  
  204. (* Is a drive a CD-ROM with MSCDEX driver installed *)
  205. procedure TEST15;
  206. var d : char;
  207. begin
  208.   for d := 'A' to 'Z' do
  209.     write ('  ', d, ': ', CDROMFN(d):5);
  210.   writeln;
  211. end;  (* test15 *)
  212.  
  213. procedure TEST16;
  214. var d : char;
  215.     v : word;
  216. begin
  217.   for d := 'A' to 'Z' do
  218.     if CDROMFN(d) then
  219.       begin
  220.         v := MSCVERFN (d);
  221.         writeln (d, ': version ', Hi(v), '.', Lo(v));
  222.       end;
  223. end;  (* test16 *)
  224.  
  225.  
  226. (* Main program
  227.    If you just want a particular test, comment the others away, just as
  228.    I have done.
  229.    If you want pauses, put readln where appropriate *)
  230. begin
  231.   LOGO;
  232.   TEST1;
  233.   TEST2;
  234.   TEST3;
  235.   TEST4;
  236.   TEST5;
  237.   TEST6;
  238.   TEST7;
  239.   TEST8;
  240.   TEST9;
  241.   TEST10;
  242.   TEST11;
  243.   TEST12;
  244.   TEST13;
  245.   TEST14;
  246.   TEST15;
  247.   TEST16;
  248.   {}
  249.   write ('Press <-'' '); readln;
  250. end.  (* tsuntg.tst *)
  251.